home *** CD-ROM | disk | FTP | other *** search
/ Especial Multimedia / Especial Multimedia.iso / Multimed / Prg / KALENDAR.ZIP / TEST.BAS < prev    next >
BASIC Source File  |  1997-09-14  |  6KB  |  173 lines
  1. Option Explicit
  2. Type DateInfo
  3.     theDate As Long
  4.     theString As String
  5. End Type
  6.  
  7. Dim DateInfoList() As DateInfo
  8.  
  9. Type DateRange
  10.     StartDate As Long
  11.     EndDate As Long
  12.     Description As String
  13.     color As Long
  14. End Type
  15.  
  16. Dim DateRangeList() As DateRange
  17.  
  18. Global CR  As String
  19.  
  20. '==========
  21. ' Some Windows API Declarations
  22. Type Rect
  23.     left As Integer
  24.     top As Integer
  25.     right As Integer
  26.     bottom As Integer
  27. End Type
  28.  
  29. Type POINTAPI
  30.     X As Integer
  31.     Y As Integer
  32. End Type
  33.  
  34. Global Const PS_SOLID = 0
  35. Global Const DT_LEFT = &H0
  36. Global Const DT_SINGLELINE = &H20
  37. Global Const DT_VCENTER = &H4
  38. Global Const DT_CENTER = &H1
  39. Global Const LTGRAY_BRUSH = 1
  40. Global Const WHITE_BRUSH = 0
  41. Global Const FW_NORMAL = 400
  42. Global Const FW_BOLD = 700
  43. Global Const LOGPIXELSX = 88    '  Logical pixels/inch in X
  44. Global Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
  45. Global Const DEFAULT_PITCH = 0
  46. Global Const FF_DONTCARE = 0    '  Don't care or don't know.
  47. Global Const NULL_PEN = 8
  48. Global Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
  49. Global Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
  50.  
  51. Global Const TRANSPARENT = 1
  52. Global Const DT_WORDBREAK = &H10
  53. Global Const BLACK_PEN = 7
  54.  
  55. Declare Function CreatePen Lib "GDI" (ByVal nPenStyle As Integer, ByVal nWidth As Integer, ByVal crColor As Long) As Integer
  56. Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
  57. Declare Function SetBkColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  58. Declare Function setBkMode Lib "GDI" (ByVal hDC As Integer, ByVal nBkMode As Integer) As Integer
  59. Declare Function SetTextColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  60. Declare Function Rectangle Lib "GDI" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
  61. Declare Function DrawText Lib "User" (ByVal hDC As Integer, ByVal lpStr As String, ByVal nCount As Integer, lpRect As Rect, ByVal wFormat As Integer) As Integer
  62. Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
  63. Declare Function GetStockObject Lib "GDI" (ByVal nIndex As Integer) As Integer
  64. Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
  65. Declare Function CreateFont% Lib "GDI" (ByVal H%, ByVal W%, ByVal E%, ByVal O%, ByVal W%, ByVal I%, ByVal U%, ByVal S%, ByVal C%, ByVal OP%, ByVal CP%, ByVal Q%, ByVal PAF%, ByVal F$)
  66. Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
  67. Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
  68. Declare Function MoveTo Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long
  69. Declare Function LineTo Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Integer
  70. Declare Function Ellipse Lib "GDI" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
  71. Declare Sub InflateRect Lib "User" (lpRect As Rect, ByVal X As Integer, ByVal Y As Integer)
  72.  
  73. Sub DateInfoAdd (aDate As Long, aString As String)
  74. Dim num As Integer
  75. Dim I As Integer
  76. Dim found As Integer
  77.  
  78.     found = False
  79.     On Error Resume Next
  80.     num = UBound(DateInfoList)
  81.     If Err <> 0 Then
  82.     num = 0
  83.     End If
  84.  
  85.     For I = 0 To num - 1
  86.     If DateInfoList(I).theDate = aDate Then
  87.         found = True
  88.         Exit For
  89.     End If
  90.     Next
  91.     
  92.     If Not found Then
  93.     On Error Resume Next
  94.     num = num + 1
  95.     
  96.     ReDim Preserve DateInfoList(num) As DateInfo
  97.     
  98.     DateInfoList(num - 1).theDate = aDate
  99.     DateInfoList(num - 1).theString = aString
  100.     Else
  101.     DateInfoList(I).theString = DateInfoList(I).theString + CR + aString
  102.     End If
  103. End Sub
  104.  
  105. Sub DateInfoMove (oldDate As Long, newDate As Long)
  106. Dim I As Integer
  107.     For I = 0 To UBound(DateInfoList) - 1
  108.     If DateInfoList(I).theDate = oldDate Then
  109.         DateInfoList(I).theDate = newDate
  110.         Exit Sub
  111.     End If
  112.     Next
  113. End Sub
  114.  
  115. Sub DateRangeAdd (FromDate As Long, ToDate As Long, Desc As String, color As Long)
  116. Dim num As Integer
  117. Dim I As Integer
  118. Dim found As Integer
  119.  
  120.     found = False
  121.     On Error Resume Next
  122.     num = UBound(DateRangeList)
  123.     If Err <> 0 Then
  124.     num = 0
  125.     End If
  126.  
  127.     On Error Resume Next
  128.     num = num + 1
  129.     
  130.     ReDim Preserve DateRangeList(num) As DateRange
  131.     
  132.     DateRangeList(num - 1).StartDate = FromDate
  133.     DateRangeList(num - 1).EndDate = ToDate
  134.     DateRangeList(num - 1).Description = Desc
  135.     DateRangeList(num - 1).color = color
  136.  
  137.  
  138. End Sub
  139.  
  140. Function GetDateInfo (aDate As Long) As String
  141. Dim I As Integer
  142.  
  143.     For I = 0 To UBound(DateInfoList) - 1
  144.     If DateInfoList(I).theDate = aDate Then
  145.         GetDateInfo = DateInfoList(I).theString
  146.         Exit Function
  147.     End If
  148.     Next
  149.  
  150.     GetDateInfo = ""
  151. End Function
  152.  
  153. Function GetDateRangeInfo (aDate As Long, Info As DateRange)
  154. Dim I As Integer
  155.  
  156.     On Error Resume Next
  157.     For I = 0 To UBound(DateRangeList) - 1
  158.     If DateRangeList(I).StartDate <= aDate And DateRangeList(I).EndDate >= aDate Then
  159.         Info = DateRangeList(I)
  160.         GetDateRangeInfo = True
  161.         Exit Function
  162.     End If
  163.     Next
  164.  
  165.     GetDateRangeInfo = False
  166.  
  167. End Function
  168.  
  169. Sub SetDescription (S As String)
  170.     Form6.txtSampleDescription.Text = S
  171. End Sub
  172.  
  173.